home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / strports.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-09  |  5.1 KB  |  235 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48. /* {Ports - string ports}
  49.  * 
  50.  */
  51.  
  52. #ifdef __STDC__
  53. static int 
  54. prinstpt (SCM exp, SCM port, int writing)
  55. #else
  56. static int 
  57. prinstpt (exp, port, writing)
  58.      SCM exp;
  59.      SCM port;
  60.      int writing;
  61. #endif
  62. {
  63.   scm_prinport (exp, port, "string");
  64.   return !0;
  65. }
  66.  
  67. #ifdef __STDC__
  68. static int 
  69. stputc (int c, SCM p)
  70. #else
  71. static int 
  72. stputc (c, p)
  73.      int c;
  74.      SCM p;
  75. #endif
  76. {
  77.   sizet ind = INUM (CAR (p));
  78.   if (ind >= LENGTH (CDR (p)))
  79.     scm_resizuve (CDR (p), MAKINUM (ind + (ind >> 1)));
  80.   CHARS (CDR (p))[ind] = c;
  81.   CAR (p) = MAKINUM (ind + 1);
  82.   return c;
  83. }
  84.  
  85. #ifdef __STDC__
  86. static sizet 
  87. stwrite (char *str, sizet siz, sizet num, SCM p)
  88. #else
  89. static sizet 
  90. stwrite (str, siz, num, p)
  91.      char *str;
  92.      sizet siz;
  93.      sizet num;
  94.      SCM p;
  95. #endif
  96. {
  97.   sizet ind = INUM (CAR (p));
  98.   sizet len = siz * num;
  99.   char *dst;
  100.   if (ind + len >= LENGTH (CDR (p)))
  101.     scm_resizuve (CDR (p), MAKINUM (ind + len + ((ind + len) >> 1)));
  102.   dst = &(CHARS (CDR (p))[ind]);
  103.   while (len--)
  104.     dst[len] = str[len];
  105.   CAR (p) = MAKINUM (ind + siz * num);
  106.   return num;
  107. }
  108.  
  109. #ifdef __STDC__
  110. static int 
  111. stputs (char *s, SCM p)
  112. #else
  113. static int 
  114. stputs (s, p)
  115.      char *s;
  116.      SCM p;
  117. #endif
  118. {
  119.   stwrite (s, 1, strlen (s), p);
  120.   return 0;
  121. }
  122.  
  123. #ifdef __STDC__
  124. static int 
  125. stgetc (SCM p)
  126. #else
  127. static int 
  128. stgetc (p)
  129.      SCM p;
  130. #endif
  131. {
  132.   sizet ind = INUM (CAR (p));
  133.   if (ind >= LENGTH (CDR (p)))
  134.     return EOF;
  135.   CAR (p) = MAKINUM (ind + 1);
  136.   return CHARS (CDR (p))[ind];
  137. }
  138.  
  139. #ifdef __STDC__
  140. SCM 
  141. scm_mkstrport (SCM pos, SCM str, long modes, char * caller)
  142. #else
  143. SCM 
  144. scm_mkstrport (pos, str, modes, caller)
  145.      SCM pos;
  146.      SCM str;
  147.      long modes;
  148.      char * caller;
  149. #endif
  150. {
  151.   SCM z;
  152.   ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
  153.   ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
  154.   str = scm_cons(pos, str);
  155.   NEWCELL (z);
  156.   DEFER_INTS;
  157.   SETCHARS(z, str);
  158.   CAR (z) = tc16_strport | modes;
  159.   scm_add_to_port_table (z);
  160.   ALLOW_INTS;
  161.   return z;
  162. }
  163.  
  164. PROC (s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string);
  165. #ifdef __STDC__
  166. SCM 
  167. scm_call_with_output_string (SCM proc)
  168. #else
  169. SCM 
  170. scm_call_with_output_string (proc)
  171.      SCM proc;
  172. #endif
  173. {
  174.   SCM p = scm_mkstrport(INUM0, scm_make_string(MAKINUM(30), SCM_UNDEFINED),
  175.             OPN | WRTNG,
  176.             s_call_with_output_string);
  177.   scm_apply (proc, p, listofnull);
  178.   return scm_resizuve (CDR (CDR (p)), CAR (CDR (p)));
  179. }
  180.  
  181. PROC (s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string);
  182. #ifdef __STDC__
  183. SCM 
  184. scm_call_with_input_string (SCM str, SCM proc)
  185. #else
  186. SCM 
  187. scm_call_with_input_string (str, proc)
  188.      SCM str;
  189.      SCM proc;
  190. #endif
  191. {
  192.   SCM p = scm_mkstrport(INUM0, str, OPN | RDNG, s_call_with_input_string);
  193.   return scm_apply (proc, p, listofnull);
  194. }
  195.  
  196. #ifdef __STDC__
  197. static int 
  198. noop0 (FILE *stream)
  199. #else
  200. static int 
  201. noop0 (stream)
  202.      FILE *stream;
  203. #endif
  204. {
  205.   return 0;
  206. }
  207.  
  208.  
  209. scm_ptobfuns scm_stptob =
  210. {
  211.   scm_markcdr,
  212.   noop0,
  213.   prinstpt,
  214.   0,
  215.   stputc,
  216.   stputs,
  217.   stwrite,
  218.   noop0,
  219.   stgetc,
  220.   0
  221. };
  222.  
  223.  
  224. #ifdef __STDC__
  225. void
  226. scm_init_strports (void)
  227. #else
  228. void
  229. scm_init_strports ()
  230. #endif
  231. {
  232. #include "strports.x"
  233. }
  234.  
  235.